home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / tdecl / instance.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  12.4 KB  |  304 lines  |  [TEXT/CCL2]
  1. rom the decls in the instances.
  2. ;;;     
  3.  
  4. ;;; Instances-decl to instance definition conversion
  5. ;;; Errors detected:
  6. ;;;  Class must be a class
  7. ;;;  Data type must be an alg
  8. ;;;  Tyvars must be distinct
  9. ;;;  Correct number of tyvars
  10. ;;;  Context applies only to tyvars in simple
  11. ;;;  C-T restriction
  12.  
  13. ;;; Needs work for interface files.
  14.  
  15. (define (instance->def inst-decl interface?)
  16.  (recover-errors '#f
  17.   (remember-context inst-decl
  18.     (with-slots instance-decl (context class simple decls) inst-decl
  19.       (resolve-type simple)
  20.       (resolve-class class)
  21.       (let ((alg-def (tycon-def simple))
  22.         (class-def (class-ref-class class)))
  23.         (when (and (not interface?)
  24.            (not (algdata? (tycon-def simple))))
  25.       (signal-datatype-required (tycon-def simple)))
  26.         (let ((tyvars (simple-tyvar-list simple)))
  27.       (resolve-signature-aux tyvars context)
  28.       (let ((old-inst (lookup-instance alg-def class-def))
  29.             (inst (new-instance class-def alg-def tyvars)))
  30.           (setf (ast-node-line-number inst)
  31.             (ast-node-line-number inst-decl))
  32.           (setf (instance-context inst) context)
  33.           (setf (instance-decls inst) decls)
  34.           (setf (instance-ok? inst) '#t)
  35.           (setf (instance-in-interface? inst) interface?)
  36.           (when (and (not interface?)
  37.              (not (eq? old-inst '#f))
  38.              (not (instance-in-interface? old-inst))
  39.              (not (instance-special? old-inst)))
  40.          (signal-multiple-instance inst old-inst))
  41.           (when (and (not (eq? *module-name* (def-module alg-def)))
  42.              (not (eq? *module-name* (def-module class-def))))
  43.             (signal-c-t-rule-violation inst class-def alg-def))
  44.           (unless interface?
  45.          (setf (instance-runtime-var inst)
  46.                (make-new-var (string-append
  47.                        (symbol->string (def-name class-def))
  48.                        "-"
  49.                        (symbol->string (def-name alg-def))
  50.                        "-instance"))))
  51.           inst)))))))
  52.  
  53. (define (signal-datatype-required def)
  54.   (phase-error 'datatype-required
  55.     "Synonym types such as ~a cannot be declared as an instance of a class."
  56.     (symbol->string (def-name def))))
  57.  
  58. (define (signal-c-t-rule-violation inst class-def alg-def)
  59.   (phase-error/objs 'c-t-rule-violation (list inst class-def alg-def)
  60.     "C-T rule violation.  The instance ~A must be defined in either~%~
  61.      the module defining ~A or the module defining ~A."
  62.      (get-object-name inst) (get-object-name class-def)
  63.      (get-object-name alg-def)))
  64.  
  65. (define (signal-multiple-instance inst other-inst)
  66.   (phase-error/objs 'multiple-instance (list inst other-inst)
  67.     "The instance ~a is already defined." (get-object-name inst)))
  68.  
  69. ;;; This generates the dictionary for each instance and makes a few final
  70. ;;; integrity checks in the instance context.  This happens after derived
  71. ;;; instances are inserted.
  72.  
  73. (define (expand-instance-decls inst interface?)
  74.   (when (instance-ok? inst)
  75.     (with-slots instance (class algdata dictionary decls context tyvars) inst
  76.      (let ((simple (**tycon/def algdata (map (function **tyvar) tyvars))))
  77.       (setf (instance-gcontext inst)
  78.         (gtype-context (ast->gtype/inst context simple)))
  79.       (if interface?
  80.        (setf (instance-methods inst) '())
  81.     ;;; The rest of this is not needed for interface definitions
  82.        (with-slots class (super* method-vars) class
  83.     ;; Before computing signatures uniquify tyvar names to prevent
  84.         ;; collision with method tyvar names
  85.      (let ((new-tyvars (map (lambda (tyvar) (tuple tyvar (gentyvar "tv")))
  86.                 (instance-tyvars inst))))
  87.       (setf (instance-tyvars inst) (map (function tuple-2-2) new-tyvars))
  88.       (setf (instance-context inst)
  89.            (map (lambda (c)
  90.                   (**context (context-class c)
  91.                  (tuple-2-2 (assq (context-tyvar c) new-tyvars))))
  92.          (instance-context inst))))
  93.     ;; Now walk over the decls & rename each method with a unique name
  94.     ;; generated by combining the class, type, and method.  Watch for
  95.     ;; multiple defs of methods and add defaults after all decls have
  96.     ;; been scanned.
  97.     (let ((methods-used '())
  98.           (new-instance-vars (map (lambda (m)
  99.                     (tuple m (method-def-var m inst)))
  100.                       method-vars)))
  101.           (dolist (decl decls)
  102.             (setf methods-used
  103.             (process-instance-decl decl new-instance-vars methods-used inst)))
  104.       ;; now add defaults when needed
  105.       (dolist (m-v new-instance-vars)
  106.            (let* ((method-var (tuple-2-1 m-v))
  107.           (definition-var (tuple-2-2 m-v))
  108.           (signature (generate-method-signature inst method-var '#t)))
  109.             (if (memq method-var methods-used)
  110.         (add-new-module-signature definition-var signature)
  111.         (let ((method-body
  112.                (if (eq? (method-var-default method-var) '#f)
  113.                (**abort (format '#f
  114.      "No definition for method ~A in instance ~A."
  115.                               (get-object-name method-var) 
  116.                   (get-object-name inst)))
  117.                (**var/def (method-var-default method-var)))))
  118.           (add-new-module-def definition-var method-body)
  119.           (add-new-module-signature definition-var signature)))))
  120.       (setf (instance-methods inst) new-instance-vars)
  121.       (add-new-module-def dictionary
  122.          (**tuple/l (append (map (lambda (m-v)
  123.                        (dict-method-ref
  124.                     (tuple-2-1 m-v)    (tuple-2-2 m-v)    inst))
  125.                      new-instance-vars)
  126.                 (map (lambda (c)
  127.                        (get-class-dict algdata c))
  128.                      super*))))
  129.       (let ((dict-sig (generate-dictionary-signature inst)))
  130.         (add-new-module-signature dictionary dict-sig))
  131.       (setf (instance-decls inst) '()))))))))
  132.  
  133. (define (dict-method-ref method-var inst-var inst)
  134.   (if (null? (signature-context (method-var-method-signature method-var)))
  135.       (**var/def inst-var)
  136.       (let* ((sig (generate-method-signature inst method-var '#f))
  137.          (ctxt (signature-context sig))
  138.          (ty (signature-type sig)))
  139.     (make overloaded-var-ref
  140.           (sig (ast->gtype ctxt ty))
  141.           (var inst-var)))))
  142.  
  143. (define (get-class-dict algdata class)
  144.   (let ((inst (lookup-instance algdata class)))
  145.     (if (eq? inst '#f)
  146.     (**abort "Missing super class")
  147.     (**var/def (instance-dictionary inst)))))
  148.                      
  149. (define (process-instance-decl decl new-instance-vars methods-used inst)
  150.   (if (valdef? decl)
  151.       (rename-instance-decl decl new-instance-vars methods-used inst)
  152.       (begin
  153.        (dolist (a (annotation-decls-annotations decl))
  154.     (cond ((annotation-value? a)
  155.            (recoverable-error 'misplaced-annotation
  156.               "Misplaced annotation: ~A~%" a))
  157.           (else
  158.            (dolist (name (annotation-decl-names a))
  159.                  (attach-method-annotation
  160.           name (annotation-decl-annotations a) new-instance-vars)))))
  161.        methods-used)))
  162.  
  163. (define (attach-method-annotation name annotations vars)
  164.   (cond ((null? vars)
  165.      (signal-bad-annotated-var name annotations))
  166.     ((eq? name (def-name (tuple-2-1 (car vars))))
  167.      (setf (var-annotations (tuple-2-2 (car vars)))
  168.            (append annotations (var-annotations (tuple-2-2 (car vars))))))
  169.     (else (attach-method-annotation name annotations (cdr vars)))))
  170.  
  171. (define (rename-instance-decl decl new-instance-vars methods-used inst)
  172.  (remember-context decl
  173.   (let ((decl-vars (collect-pattern-vars (valdef-lhs decl))))
  174.     (dolist (var decl-vars)
  175.       (let* ((method-name (var-ref-name var))
  176.          (method (resolve-toplevel-name method-name))
  177.          (m-v (assq method new-instance-vars)))
  178.           (cond ((memq method methods-used)
  179.          (signal-multiple-instance-def method-name inst))
  180.         ((eq? m-v '#f)
  181.          (signal-not-in-class method-name inst))
  182.         (else
  183.          (setf (var-ref-name var) (def-name (tuple-2-2 m-v)))
  184.          (setf (var-ref-var var) (tuple-2-2 m-v))
  185.          (push (tuple-2-1 m-v) methods-used))))))
  186.      (add-new-module-decl decl)
  187.      methods-used))
  188.  
  189. (define (signal-multiple-instance-def method inst)
  190.   (phase-error/objs  'multiple-instance-def (list inst)
  191.     "The instance declaration ~A has multiple definitions of the method ~A."
  192.      (get-object-name inst) (symbol->string method)))
  193.  
  194. (define (signal-not-in-class method inst)
  195.   (phase-error/objs 'not-in-class (list inst)
  196.     "The instance declaration ~A includes a definition for ~a,~%~
  197.      which is not one of the methods for this class."
  198.     (get-object-name inst) (symbol->string method)))
  199.  
  200. (define (method-def-var method-var inst)
  201.   (make-new-var
  202.     (string-append "i-"
  203.            (symbol->string (print-name (instance-class inst))) "-"
  204.            (symbol->string (print-name (instance-algdata inst))) "-"
  205.            (symbol->string (def-name method-var)))))
  206.  
  207. (define (generate-method-signature inst method-var keep-method-context?)
  208.   (let* ((simple-type (make-instance-type inst))
  209.      (class-context (instance-context inst))
  210.      (class-tyvar (class-tyvar (instance-class inst)))
  211.      (signature (method-var-method-signature method-var)))
  212.     (make signature
  213.       (context (if keep-method-context?
  214.                (append class-context (signature-context signature))
  215.                class-context))
  216.       (type (substitute-tyvar (signature-type signature) class-tyvar
  217.                   simple-type)))))
  218.  
  219. (define (make-instance-type inst)
  220.   (**tycon/def (instance-algdata inst)
  221.            (map (function **tyvar) (instance-tyvars inst))))
  222.  
  223. (define (generate-dictionary-signature inst)
  224.   (**signature (sort-inst-context-by-tyvar
  225.         (instance-context inst) (instance-tyvars inst))
  226.            (generate-dictionary-type inst (make-instance-type inst))))
  227.  
  228. (define (sort-inst-context-by-tyvar ctxt tyvars)
  229.   (concat (map (lambda (tyvar)
  230.          (extract-single-context tyvar ctxt)) tyvars)))
  231.  
  232. (define (extract-single-context tyvar ctxt)
  233.   (if (null? ctxt)
  234.       '()
  235.       (let ((rest (extract-single-context tyvar (cdr ctxt))))
  236.     (if (eq? tyvar (context-tyvar (car ctxt)))
  237.         (cons (car ctxt) rest)
  238.         rest))))
  239.  
  240. (define (generate-dictionary-type inst simple)
  241.   (let* ((class (instance-class inst))
  242.      (algdata (instance-algdata inst))
  243.      (tyvar (class-tyvar class)))
  244.     (**tuple-type/l (append (map (lambda (method-var)
  245.                    ;; This ignores the context associated
  246.                    ;; with a method
  247.                    (let ((sig (method-var-method-signature
  248.                             method-var)))
  249.                      (substitute-tyvar (signature-type sig)
  250.                                tyvar
  251.                                simple)))
  252.                  (class-method-vars class))
  253.                 (map (lambda (super-class)
  254.                    (generate-dictionary-type
  255.                     (lookup-instance algdata super-class)
  256.                     simple))
  257.                  (class-super* class))))))
  258.  
  259. ;;; Checks performed here:
  260. ;;;  Instance context must include the following:
  261. ;;;     Context associated with data type
  262. ;;;     Context associated with instances for each super class
  263. ;;;  All super class instances must exist
  264.  
  265. (define (check-inst-type inst)
  266.    (let* ((class (instance-class inst))
  267.       (algdata (instance-algdata inst))
  268.       (inst-context (instance-gcontext inst))
  269.       (alg-context (gtype-context (algdata-signature algdata))))
  270.      (when (not (full-context-implies? inst-context alg-context))
  271.        (signal-instance-context-needs-alg-context inst algdata))
  272.      (dolist (super-c (class-super class))
  273.        (let ((super-inst (lookup-instance algdata super-c)))
  274.      (cond ((eq? super-inst '#f)
  275.         (signal-no-super-class-instance inst super-c))
  276.            (else
  277.         (when (not (full-context-implies?
  278.                  inst-context (instance-gcontext super-inst)))
  279.           (signal-instance-context-insufficient-for-super
  280.             inst super-inst))))))
  281.      ))
  282.  
  283. (define (signal-instance-context-needs-alg-context inst algdata)
  284.   (phase-error/objs 'instance-context-needs-alg-context (list inst algdata)
  285.     "The instance context for ~A needs to include context defined~%~
  286.      for data type ~A."
  287.     (get-object-name inst) (get-object-name algdata)))
  288.  
  289. (define (signal-no-super-class-instance inst super-c)
  290.   (phase-error/objs 'no-super-class-instance (list inst)
  291.     "The instance ~A requires that the instance ~A(~A) be defined~%~
  292.      since ~A is a superclass of ~A"
  293.     (get-object-name inst) (get-object-name super-c)
  294.     (get-object-name (instance-algdata inst))
  295.     (get-object-name super-c) (get-object-name (instance-class inst)))
  296.   (abort-compilation))
  297.  
  298. (define (signal-instance-context-insufficient-for-super inst super-inst)
  299.   (phase-error/objs 'instance-ctxt-insufficient-for-super (list inst super-inst)
  300.     "The context of instance ~A must include the context associated~%~
  301.      with the super class instance ~A."
  302.     (get-object-name inst) (get-object-name super-inst)))
  303.  
  304.